home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / games_d / hunchy.zip / CHARGEN.PAS < prev    next >
Pascal/Delphi Source File  |  1980-01-01  |  6KB  |  270 lines
  1. uses Dos,Crt,Graph,Cgadrv;
  2.  
  3. type
  4.   OneChar=array[0..7] of byte;
  5.   FontType=array[128..255] of OneChar;
  6.   Str80=string[80];
  7.  
  8. var
  9.   Font:FontType;
  10.   FontFil: file of FontType;
  11.   CurChar:array[0..7,0..7] of boolean;
  12.   x,y,ChrNo:integer;
  13.   Key:char;
  14.   OldFont,NewFont:pointer;
  15.   Quit:boolean;
  16.   Regs:Registers;
  17.  
  18. function Power(Gr,Mnt:real):integer;
  19. begin
  20.   Power:=Round(Exp(Ln(Gr)*Mnt));
  21. end;
  22.  
  23. procedure WriteAt(x,y:integer; Txt:Str80; Col:integer);
  24. var Ctr,Ch:byte;
  25. begin
  26.   TextColor(Col);
  27.   GotoXY(x,y);
  28. (*  for Ctr:=1 to Length(Txt) do begin
  29.     Ch:=Ord(Txt[Ctr]);
  30.     if Ch<128 then Inc(Ch,128);
  31.     Write(Chr(Ch));
  32.   end;*)
  33.   Write(Txt);
  34. end;
  35.  
  36. procedure InitScreen;
  37. begin
  38.   WriteAt(15,1,'THE CHARACTER SET EDITOR',3);
  39.   WriteAt(12,2,'(C) 1988-89 FireBall Software',1);
  40.   WriteAt(25,4,'Written by',2);
  41.   WriteAt(23,6,'Robert Schmidt',3);
  42.   WriteAt(1,20,'SELECT mode: arrows + ENTER selects',2);
  43.   WriteAt(1,21,'  C)lear char  D)elete set  O)rig set',2);
  44.   WriteAt(1,22,'  L)oad set  S)tore set',2);
  45.   WriteAt(1,23,'EDIT mode: arrows + INS & DEL (on/off)',2);
  46.   WriteAt(1,24,'  C)lear char   ENTER accepts,',2);
  47.   WriteAt(1,25,'  ESC - no changes',2);
  48.   SetColor(2); Rectangle(0,0,81,81);
  49.   WriteAt(13,3,'╔═╗',2);
  50.   WriteAt(13,4,'║ ║',2);
  51.   WriteAt(13,5,'╚═╝',2);
  52.   WriteAt(12,8,'(       )',2);
  53. end;
  54.  
  55. procedure ShowBit(x,y:integer);
  56. begin
  57.   SetFillStyle(1,3*Ord(CurChar[x,y]));
  58.   Bar(x*10+1,y*10+1,(x+1)*10,(y+1)*10);
  59.   PutPixel(104+x,24+y,3*Ord(CurChar[x,y]));
  60. end;
  61.  
  62. procedure ShowCurChar(ChrNo:integer);
  63. var
  64.   x,y:integer;
  65.   Mask:byte;
  66. begin
  67.   for x:=0 to 7 do begin
  68.     Mask:=Power(2,7-x);
  69.     for y:=0 to 7 do begin
  70.       CurChar[x,y]:=(Font[ChrNo,y] and Mask)=Mask;
  71.       ShowBit(x,y);
  72.     end;
  73.   end;
  74. end;
  75.  
  76. procedure ShowChars;
  77. var
  78.   ChrNo:integer;
  79. begin
  80.   for x:=1 to 40 do
  81.     for y:=1 to 4 do begin
  82.       ChrNo:=y*40+x+87;
  83.       if ChrNo<=255 then WriteAt(x,y*2+10,Chr(ChrNo),1);
  84.     end;
  85. end;
  86.  
  87. procedure GetCoords(ChrNo:integer; var x,y:integer);
  88. begin
  89.   x:=(ChrNo-7) mod 40;
  90.   y:=((ChrNo-7) div 40)*2+6;
  91.   if x=0 then begin
  92.     x:=40; Dec(y,2);
  93.   end;
  94. end;
  95.  
  96. procedure CreateChar(ChrNo:integer);
  97. var
  98.   x,y:integer;
  99.   Mask:byte;
  100. begin
  101.   FillChar(Font[ChrNo],SizeOf(Font[ChrNo]),#0);
  102.   for x:=0 to 7 do begin
  103.     Mask:=Power(2,7-x);
  104.     for y:=0 to 7 do
  105.       Font[ChrNo,y]:=Font[ChrNo,y] or (Mask*Ord(CurChar[x,y]));
  106.   end;
  107.   GetCoords(ChrNo,x,y);
  108.   WriteAt(x,y,Chr(ChrNo),1);
  109. end;
  110.  
  111. procedure GetFileName(var Name:Str80);
  112. var
  113.   Buffer:record
  114.     MaxLen:byte;
  115.     Data:Str80;
  116.   end;
  117. begin
  118.   Window(22,8,40,10);
  119.   WriteAt(1,1,'Enter filename:',1);
  120.   Writeln; TextColor(3);
  121.   with Regs do begin
  122.     AH:=$A;
  123.     DS:=Seg(Buffer);
  124.     DX:=Ofs(Buffer);
  125.     Buffer.MaxLen:=19;
  126.     Intr($21,Regs);
  127.     Name:=Buffer.Data;
  128.   end;
  129.   ClrScr;
  130.   Window(1,1,80,25);
  131. end;
  132.  
  133. procedure SaveFont;
  134. var
  135.   FontName:Str80;
  136. begin
  137.   GetFileName(FontName);
  138.   if FontName<>'' then begin
  139.     Assign(FontFil,FontName); {$I-}
  140.     ReWrite(FontFil);         {$I+}
  141.     if IOresult=0 then begin
  142.       Write(FontFil,Font);
  143.       Close(FontFil);
  144.     end;
  145.   end;
  146. end;
  147.  
  148. procedure SelectChar(var ChrNo:integer);
  149. var
  150.   Key,AltCh:char;
  151.   x,y:integer;
  152.   St,FontName:Str80;
  153. begin
  154.   GetCoords(ChrNo,x,y);
  155.   repeat
  156.     Key:=#255;
  157.     if KeyPressed then Key:=UpCase(ReadKey);
  158.     case Key of
  159.       #0:if KeyPressed then begin
  160.         WriteAt(x,y+1,#32,0);
  161.         Key:=ReadKey;
  162.         case Key of
  163.           'H':if ChrNo>=168 then Dec(ChrNo,40);
  164.           'P':if ChrNo<=215 then Inc(ChrNo,40);
  165.           'K':if ChrNo>=129 then Dec(ChrNo);
  166.           'M':if ChrNo<=254 then Inc(ChrNo);
  167.           'G':ChrNo:=128;
  168.           'O':ChrNo:=255;
  169.         end;
  170.       end;
  171.       'C':begin
  172.         FillChar(Font[ChrNo],SizeOf(Font[ChrNo]),#0);
  173.         WriteAt(x,y,Chr(ChrNo),1);
  174.       end;
  175.       'D':begin
  176.         FillChar(Font,SizeOf(Font),#0);
  177.         ShowChars;
  178.       end;
  179.       'O':begin
  180.         Move(OldFont^,NewFont^,SizeOf(Font));
  181.         ShowChars;
  182.       end;
  183.       'L':begin
  184.         GetFileName(FontName);
  185.         if FontName<>'' then begin
  186.           Assign(FontFil,FontName); {$I-}
  187.           Reset(FontFil);           {$I+}
  188.           if IOresult=0 then begin
  189.             Read(FontFil,Font);
  190.             Close(FontFil);
  191.             ShowChars;
  192.           end else Write(#7#7);
  193.         end;
  194.       end;
  195.       'S':SaveFont;
  196.     end;
  197.     GetCoords(ChrNo,x,y);
  198.     WriteAt(x,y+1,#94,3);
  199.     WriteAt(14,4,Chr(ChrNo),3);
  200.     Str(ChrNo:3,St);
  201.     WriteAt(13,6,St,3);
  202.     Str((ChrNo-128):3,St);
  203.     AltCh:=Chr(ChrNo-128);
  204.     if AltCh in [#7,#8,#10,#13] then AltCh:=#32;
  205.     WriteAt(13,8,#39+AltCh+#39+':'+St,3);
  206.   until Key in [#13,#27];
  207.   Quit:=(Key=#27);
  208. end;
  209.  
  210. procedure EditChar(ChrNo:integer);
  211. var
  212.   Key:char;
  213. begin
  214.   ShowCurChar(ChrNo);
  215.   x:=0; y:=0;
  216.   repeat
  217.     Key:=#255;
  218.     if KeyPressed then Key:=UpCase(ReadKey);
  219.     case Key of
  220.       #0:if KeyPressed then begin
  221.         ShowBit(x,y);
  222.         Key:=ReadKey;
  223.         case Key of
  224.           'H':begin Dec(y); if y<0 then y:=7; end;
  225.           'P':begin Inc(y); if y>7 then y:=0; end;
  226.           'K':begin Dec(x); if x<0 then x:=7; end;
  227.           'M':begin Inc(x); if x>7 then x:=0; end;
  228.           'R':CurChar[x,y]:=True;
  229.           'S':CurChar[x,y]:=False;
  230.         end;
  231.       end;
  232.       'C':for x:=0 to 7 do
  233.         for y:=0 to 7 do begin
  234.           CurChar[x,y]:=False;
  235.           ShowBit(x,y);
  236.         end;
  237.     end;
  238.     if Key in ['R','S'] then ShowBit(x,y);
  239.     SetFillStyle(1,1);
  240.     Bar(x*10+3,y*10+3,(x+1)*10-2,(y+1)*10-2);
  241.   until Key in [#13,#27];
  242.   if Key=#13 then CreateChar(ChrNo);
  243.   ShowBit(x,y);
  244. end;
  245.  
  246. begin
  247.   GetIntVec ($1F,OldFont);
  248.   NewFont:=Ptr(Seg(Font),Ofs(Font));
  249.   SetIntVec ($1F,NewFont);
  250.   Move(OldFont^,NewFont^,SizeOf(Font));
  251.   RegisterCGA; InitCGA(CGAC1);
  252.   DirectVideo:=False;
  253.   InitScreen;
  254.   ShowChars;
  255.   ChrNo:=128;
  256.   x:=0; y:=0;
  257.   Quit:=False;
  258.   SelectChar(ChrNo);
  259.   while not Quit do begin
  260.     EditChar(ChrNo);
  261.     SelectChar(ChrNo);
  262.   end;
  263.   Window(22,9,40,10);
  264.   WriteAt(1,1,'Save font first?',3);
  265.   repeat Key:=UpCase(ReadKey); until Key in ['Y','N'];
  266.   ClrScr;
  267.   if Key = 'Y' then SaveFont;
  268. (*  SetIntVec ($1F,OldFont);*)
  269. end.
  270.